home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / pcturtle.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  4.6 KB  |  175 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         pcturtle.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  This is a sample XLISP program. It implements a simple form of
  7. ;        programmable turtle for IBM-PC compatible machines.
  8. ;        To run it:
  9. ;            A>xlisp pt
  10. ;        This should cause the screen to be cleared and two turtles to
  11. ;        appear. They should each execute their simple programs and then
  12. ;        the prompt should return.  Look at the code to see how all of this works.
  13. ; Author:       ???
  14. ; Created:      Sat Oct  5 20:57:21 1991
  15. ; Modified:     Sat Oct  5 20:58:38 1991 (Niels Mayer) mayer@hplnpm
  16. ; Language:     Lisp
  17. ; Package:      N/A
  18. ; Status:       X11r5 contrib tape release
  19. ;
  20. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  21. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  22. ;
  23. ; Permission to use, copy, modify, distribute, and sell this software and its
  24. ; documentation for any purpose is hereby granted without fee, provided that
  25. ; the above copyright notice appear in all copies and that both that
  26. ; copyright notice and this permission notice appear in supporting
  27. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  28. ; used in advertising or publicity pertaining to distribution of the software
  29. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  30. ; makes no representations about the suitability of this software for any
  31. ; purpose.  It is provided "as is" without express or implied warranty.;
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33.  
  34. ; Get some more memory
  35. (expand 1)
  36.  
  37. ; Move the cursor to the currently set bottom position and clear the line
  38. ;  under it
  39. (defun bottom ()
  40.     (set-cursor by bx)
  41.     (clear-eos))
  42.  
  43. ; Clear the screen and go to the bottom
  44. (defun cb ()
  45.     (clear)
  46.     (bottom))
  47.  
  48.  
  49. ; ::::::::::::
  50. ; :: Turtle ::
  51. ; ::::::::::::
  52.  
  53. ; Define "Turtle" class
  54. (setq Turtle (Class :new '(xpos ypos char)))
  55.  
  56. ; Answer ":isnew" by initing a position and char and displaying.
  57. (Turtle :answer :isnew '() '(
  58.     (setq xpos (setq newx (+ newx 1)))
  59.     (setq ypos 12)
  60.     (setq char "*")
  61.     (self :display)
  62.     self))
  63.  
  64. ; Message ":display" prints its char at its current position
  65. (Turtle :answer :display '() '(
  66.     (set-cursor ypos xpos)
  67.     (princ char)
  68.     (bottom)
  69.     self))
  70.  
  71. ; Message ":char" sets char to its arg and displays it
  72. (Turtle :answer :char '(c) '(
  73.     (setq char c)
  74.     (self :display)))
  75.  
  76. ; Message ":goto" goes to a new place after clearing old one
  77. (Turtle :answer :goto '(x y) '(
  78.     (set-cursor ypos xpos) (princ " ")
  79.     (setq xpos x)
  80.     (setq ypos y)
  81.     (self :display)))
  82.  
  83. ; Message ":up" moves up if not at top
  84. (Turtle :answer :up '() '(
  85.     (if (> ypos 1)
  86.     (self :goto xpos (- ypos 1))
  87.     (bottom))))
  88.  
  89. ; Message ":down" moves down if not at bottom
  90. (Turtle :answer :down '() '(
  91.     (if (< ypos by)
  92.     (self :goto xpos (+ ypos 1))
  93.     (bottom))))
  94.  
  95. ; Message ":right" moves right if not at right
  96. (Turtle :answer :right '() '(
  97.     (if (< xpos 80)
  98.     (self :goto (+ xpos 1) ypos)
  99.     (bottom))))
  100.  
  101. ; Message ":left" moves left if not at left
  102. (Turtle :answer :left '() '(
  103.     (if (> xpos 1)
  104.     (self :goto (- xpos 1) ypos)
  105.     (bottom))))
  106.  
  107.  
  108. ; :::::::::::::
  109. ; :: PTurtle ::
  110. ; :::::::::::::
  111.  
  112. ; Define "DPurtle" programable turtle class
  113. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  114.  
  115. ; Message ":program" stores a program
  116. (PTurtle :answer :program '(p) '(
  117.     (setq prog p)
  118.     (setq pc prog)
  119.     self))
  120.  
  121. ; Message ":step" executes a single program step
  122. (PTurtle :answer :step '() '(
  123.     (if (null pc)
  124.     (setq pc prog))
  125.     (if pc
  126.     (progn (self (car pc))
  127.            (setq pc (cdr pc))))
  128.     self))
  129.  
  130. ; Message ":step#" steps each turtle program n times
  131. (PTurtle :answer :step# '(n) '(
  132.     (dotimes (x n) (self :step))
  133.     self))
  134.  
  135.  
  136. ; ::::::::::::::
  137. ; :: PTurtles ::
  138. ; ::::::::::::::
  139.  
  140. ; Define "PTurtles" class
  141. (setq PTurtles (Class :new '(turtles)))
  142.  
  143. ; Message ":make" makes a programable turtle and adds it to the collection
  144. (PTurtles :answer :make '(x y &aux newturtle) '(
  145.     (setq newturtle (PTurtle :new))
  146.     (newturtle :goto x y)
  147.     (setq turtles (cons newturtle turtles))
  148.     newturtle))
  149.  
  150. ; Message ":step" steps each turtle program once
  151. (PTurtles :answer :step '() '(
  152.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  153.     self))
  154.  
  155. ; Message ":step#" steps each turtle program n times
  156. (PTurtles :answer :step# '(n) '(
  157.     (dotimes (x n) (self :step))
  158.     self))
  159.  
  160.  
  161. ; Initialize things and start up
  162. (setq bx 1)
  163. (setq by 21)
  164. (setq newx 1)
  165.  
  166. ; Create some programmable turtles
  167. (cb)
  168. (setq turtles (PTurtles :new))
  169. (setq t1 (turtles :make 40 10))
  170. (setq t2 (turtles :make 41 10))
  171. (t1 :program '(:left :right :up :down))
  172. (t2 :program '(:right :left :down :up))
  173.  
  174.  
  175.